perm filename WTREST.TUE[MSS,LCS] blob
sn#105223 filedate 1974-06-04 generic text, type T, neo UTF8
00100 C******* SUBRS TAIL, FERMTA, REST, RDDATA, BREP, EXCH, SORT2, ALPHA
00200 SUBROUTINE TAIL(RJX,RA,RMINI)
00300 COMMON /STF/RSTFAC(8),RSTJC
00400 COMMON /PLTR/IPLT,RHT,DIS
00500 DIMENSION ITAIL(16)
00600 DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
00700 1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
00800 Q=-1.
00900 IF(RA)Q=1.
00910 ITAIL(1)=10
00955 IF(IPLT)ITAIL(1)=16
01000 CALL CENTER(RJY)
01100 CALL JDRAW(ITAIL,RJX,RJY,RMINI,1.,Q)
01200 1 IF(IPLT.GE.0)RETURN
01300 IF(RMINI.NE.RSTJC)Q=Q*.6
01400 CC CALL OLDFIL(ITAIL(10),RJX,RJY,ABS(Q),Q)
01500 CALL FILLMS(12,ITAIL(5),RJX,RJY,ABS(Q),Q)
01600 C RA=-,STEM UP; RA=+, STEM DOWN.
01700 END
01800
01900 SUBROUTINE REST
02000 COMMON /STF/RSTFAC(8),RSTJC/PLTR/IPLT,RHT,DIS
02100 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02200 EQUIVALENCE(JE,JQ(3))
02300 DIMENSION LRST(3),IRST(47),MR(2),MF(2)
02400 DATA IRST/9,100000033,160033,160032, 32,31 ,160031 ,160030,
02600 1 30, 23,100000051,100038,32,110017,200050044, 32 ,50026,
02700 1 100038,50044,100110017,70018,50017,50015,60011, 10016,
02800 1 18, 20,10022,30023, 50023, 70022,110017,
02900 1 15,100030033, 40032, 80032,120035,150039,70014,200010037,
03000 1 30039, 50039, 70037, 70035, 50033, 30033,10035/
03100 1,LRST/1,10,33/,MR/18,8/,MF/15,40/
03150 C LRST = BEGINNING OF EACH REST, MR=FILLER WDCNT, MF=FILL START.
03200
03300 IF(LRST(1).EQ.0)CALL RDDATA('REST',LRST,IRST)
03400 L=JE
03500 IF(L.GT.1)L=1
03600 IF(L)L=-1
03700 C L>3 WHEN SEVERAL TAILS ON REST
03800 CALL CENTER(CENTR)
03900 IF(JE.EQ.-2)CENTR=CENTR+9.4*RSTJC
04000 CALL JDRAW(IRST(LRST(L+2)),RJB,CENTR,RSTJC,1.,1.)
04100 IF(JE.OR.IPLT.GE.0)RETURN
04200 L=L+1
04300 CALL FILLMS(MR(L),IRST(MF(L)),RJB,CENTR,1.,1.)
04400 C WHY GO THROUGH NOTWRT??
04500 END
04600
04700 SUBROUTINE RDDATA(NM,JARY,IARY)
04800 C READS DATA
04900 DIMENSION JARY(1),IARY(1)
05000 REWIND 23
05100 CALL IFILE(23,NM)
05200 READ(23,5)K,(JARY(K),K=1,10)
05300 N=1
05400 1 READ(23,5,END=2)K,L,(IARY(K),K=N,N+L-1)
05500 N=N+L
05600 GO TO 1
05700 2 RETURN
05800 5 FORMAT(12I)
05900 END
06000
06100 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
06200 SUBROUTINE BREP(RJB,RSTJC)
06300 DIMENSION IREP(35)
06400 DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
06500 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
06600 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
06700 1,100270022,280021,290021,300022,300023,290024,280024,270023
06800 1,270022, 300022, 270023, 290023/
06900 CC IF(JREP(1).EQ.0)CALL RDDATA('BREP',JREP,IREP)
07000 CALL CENTER(R)
07100 CALL JDRAW(IREP,RJB,R,RSTJC,1.,1.)
07200 END
07300
07400 SUBROUTINE FERMTA(RINV)
07500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07600 COMMON /PLTR/IPLT,RHT,DIS
07700 COMMON /STF/RSTFAC(8),RSTJC
07800 DIMENSION JFERM(24)
07900 DATA JFERM/24,310020003,10010010,20015,60017,110017,160015,
08000 1 190010,200003,170010,150012,120014,70014,30012,10010,
08100 1 10020003,100070007,80008,100008,110007,110006,100005,80005
08200 1 ,70006/
08300 CC IF(JFERM(1).EQ.0)CALL RDDATA('FERM',JFERM,IFERM)
08400 CC R=INV
08500 CALL JDRAW(JFERM,RJB,CENTR,RSTJC,1.,RINV)
08600 CC IF(IPLT)CALL OLDFIL(IFERM(IFERM(1)+2),RJB,CENTR,1.,RINV)
08700 IF(IPLT)CALL FILLMS(JFERM(1),JFERM(2),RJB,CENTR,1.,RINV)
08800 END
08900
09000 SUBROUTINE EXCH(X,Y)
09100 Z=X
09200 X=Y
09300 Y=Z
09400 END
09500 SUBROUTINE SORT2(RPOS,M)
09600 DIMENSION RPOS(2,200)
09700 L=2
09800 3 J=-1
09900 RX=RPOS(1,L-1)
10000 DO 2 K=L,M
10100 IF(RPOS(1,K).GE.RX)GO TO 2
10200 RX=RPOS(1,K)
10300 C WHY WERE ALL THE RX'S JX ????? 9/6/73
10400 J=K
10500 2 CONTINUE
10600 IF(J)GO TO 4
10700 K=L-1
10800 CALL EXCH(RPOS(1,K),RPOS(1,J))
10900 CALL EXCH(RPOS(2,K),RPOS(2,J))
11000 4 L=L+1
11100 IF(L.LE.M)GO TO 3
11200 END
00100 C****** FOR LISTS OF LETTERS, ETC. *******
00200 SUBROUTINE ALPHA
00300 COMMON /PLTR/IPLT,RHT,DIS
00400 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00500 EQUIVALENCE(JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3)),
00600 1(RJH,RJQ(6)),(NRJ,RJQ(8)),
00700 1(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
00800 1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
00900 COMMON/STF/RSTFAC(8),RSTJC
01000 DATA RS/1.1/,R4/-2.1/,RSPC/.9/,JFIX/-1/
01100
01200 IF(JA.EQ.20)GO TO 20
01300 CC IFNT=0
01400 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
01500 C ONLY 11 LETTERS WITHOUT FONT RESET.
01600 CC JA=5
01700 54 R=19.7*RJE*RSTJC
01800 RB=JB
01900 CC J=R
02000 CC RND=R-J
02100 CC R=0
02200 CC RSX=RS
02300 DO 50 KA=4,6
02400 JY=RJQ(KA)*100.+.2
02500 JX=1000000
02600 DO 53 LA=1,4
02700 JF=JY/JX
02800 IF(JF.EQ.47.OR.JF.GT.90)GO TO 2
02900 IF(JF.LT.47.AND.IFNT.EQ.0)GO TO 3
03000 C JUMP TO USE PRIMITIVE ALPHABET.
03100 CC RS=RSX
03200 IF((JF.GT.9.AND.JF.LT.36).OR.JF.GT.47)GO TO 10
03300 C NEXT FOR NUMBERS, SPACE AND PUNCTUATION.
03400 CC RSX=RS
03500 RSX=RSPC
03600 IF(JF.GT.9)GO TO 3
03700 GO TO 4
03800 10 IF(JF.LT.47)GO TO 5
03900 IF(JF.NE.48)GO TO 7
04000 IFNT=1
04100 C $=48=UPPER CASE
04200 CC RSX=1.1
04300 GO TO 11
04400 7 IF(JF.NE.49)GO TO 8
04500 IFNT=-1
04600 C %=LOWER CASE
04700 CC RSX=.73
04800 GO TO 11
04900 8 IF(JF.NE.50)GO TO 13
05000 NR='BDR40'
05100 CC IF(JFIX)NR='FIX40'
05200 C &=NON-ITALICS -- JFIX IS TEMPORARY SWITCH 5/74
05300 13 IF(JF.NE.51)GO TO 14
05400 NR='BDI40'
05500 CC IF(JFIX)NR='FIZ40'
05600 C @=51=ITALICS
05700 14 IF(JF.NE.52)GO TO 11
05800 IFNT=0
05900 C #=52=PRIMITIVE
06000 JA=5
06100 RSX=1.
06200 GO TO 11
06300 9 IF(JF.LT.52)GO TO 11
06400 IF(JF.EQ.53)FILL=-2
06500 IF(JF.EQ.54)FILL=0
06600 C < = 53 = NO FILL, > = 54 = FILL
06700 GO TO 11
06800 5 IF(IFNT)RSX=.8
06900 IF(JF.LE.9)RSX=RSPC
07000 IF(JF.EQ.22.OR.JF.EQ.32)RSX=RSX*1.1
07100 IF(JF.EQ.1.OR.JF.EQ.18.OR.JF.EQ.19.OR.(JF.EQ.21.AND.IFNT))
07200 1 RSX=RSX*.8
07300 4 IF(JFIX.AND.IPLT.GE.0)GO TO 3
07400 C JFIX=-1 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
07500 C******** SET JFIX TO -1 IN DDT TO USE FIXED WIDTH.
07600 JE=JF
07700 IF(IFNT.AND.JE.GT.9)JE=JE+26
07800 RX=RJF
07900 RJF=RJE*.28
08000 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
08100 RY=RJG
08200 RJG=RJF
08300 RZ=RJH
08400 RW=RJD
08500 RJD=RJD+R4
08600 RJH=FILL
08700 NRJ=NR
08800 C GETS RIGHT FILE
08900 JA=11
09000 CALL NOTWRT
09100 RJF=RX
09200 RJG=RY
09300 RJH=RZ
09400 RJD=RW
09500 C PUTS BACK RIGHT STUFF
09600 IF(JFIX)GO TO 12
09700 GO TO 2
09800
09900 3 JA=5
10000 CALL NOTWRT
10100 C 47=BLANK (WAS 99)
10200 CC2 JB=JB+J
10300 12 RSX=1.
10400 2 RB=RB+R*RSX
10500 JB=ROFF(RB)
10600 CC R=R+RND
10700 CC IF(R.LT.1.0)GO TO 11
10800 CC JB=JB+1
10900 CC R=R-1.0
11000 11 JY=JY-JF*JX
11100 RSX=RS
11200 53 JX=JX/100
11300 50 CONTINUE
11400 RETURN
11500
11600 C FOR TRILLS
11700 20 R=RJB
11800 C R SAVES RJB(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
11900 C 20, POS1, STF, NT#, 0, POS2, X IF X=1 THEN NO WAVEY LINE
12000 RJE=.65
12100 JE=0
12200 JA=5
12300 JF=29
12400 C DRAWS T
12500 CALL NOTWRT
12600 JF=27
12700 C DRAWS R
12800 JB=JB+11*RSTJC
12900 51 CALL NOTWRT
13000 IF(JG.NE.0)RETURN
13100 JB=JB+16*RSTJC
13200 C RETURN IF NO WAVY LINE IS NEEDED
13300 JA=4
13400 RJB=R+4.*RSTJC
13500 JG=-2
13600 C JG IS SWITCH TO DRAW WIGGLE
13700 RJE=RJD+.8
13800 CALL ITMSUB
13900 END